;; Copyright (c) 2008-2020 Robert Virding
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;;     http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.

;; File    : lfe-eval.lfe
;; Author  : Robert Virding
;; Purpose : Lisp Flavoured Erlang interpreter.

;;; Shouldn't use macros here as macros need the evaluator! But we do.
(defmodule lfe-eval
  (export
   (expr 1) (expr 2) (gexpr 1) (gexpr 2)
   (apply 2) (apply 3)
   (body 1) (body 2)
   (guard 1) (guard 2)
   (make_letrec_env 2)
   (add_expr_func 4)
   (match 3)
   (match_when 4))
  ;; Deprecated exports.
  (export
   (eval 1) (eval 2)
   (eval_list 2))
  (import
   (from lfe_env
         (new 0)
         (add_vbinding 3)
         (add_vbindings 2)
         (get_vbinding 2)
         (add_fbinding 4)
         (add_fbindings 2)
         (get_fbinding 3)
         (add_ibinding 5)
         (get_gbinding 3))
   (from lists (reverse 1) (foldl 3) (foldr 3))
   (from orddict (find 2) (store 3)))
  (deprecated #(eval 1) #(eval 2)))

(defun eval (e) (eval e (lfe_env:new)))

(defun eval (e env) (eval-expr e env))

(defun eval_list (es env) (eval-list es env))

;; expr(Sexpr) -> Value
;; expr(Sexpr, Env) -> Value
;; Evaluate the sexpr, first expanding all macros.

(defun expr (e) (expr e (lfe_env:new)))

(defun expr (e env)
  (let ((exp (lfe_macro:expand_expr_all e env)))
    (eval-expr exp env)))

;; gexpr(guardtest) -> Value
;; gexpr(guardtest, env) -> Value

(defun gexpr (gt) (gexpr gt (lfe_env:new)))

(defun gexpr (gt env) (eval-gexpr gt env))

;; (apply function args) -> expr.
;; (apply function args env) -> Expr.
;;  This is applying interpreted Erlang functions, for applying funs
;;  use normal apply. Name scoping stops us from using apply/s
;;  internally. Args should already be evaluated.

(defun apply (f args)
  (apply-expr f args (lfe_env:new)))

(defun apply (f args env)
  (apply-expr f args env))

;; Internal function to avoid BIF name conflict
(defun apply-expr (f args env)
  (eval-apply-expr f args env))

;; (body body) -> value
;; (body body env) -> value
;; (guard guard) -> true | false
;; (guard guard env) -> true | false

(defun body (b) (body b (lfe_env:new)))

(defun body (b env) (eval-body b env))

(defun guard (g) (guard g (lfe_env:new)))

(defun guard (g env) (eval-guard g env))

(defun match_when (pat val body env)
  (match-when pat val body env))

;; (eval-expr Sexpr Environment) -> Value.
;;  Evaluate a sexpr in the current environment. Try to catch core
;;  forms by just name and check arguments arguments later. Otherwise
;;  users can redefine core forms with different number of arguments.

(defun eval-expr (e env)
  (case e
    ;; Handle the Core data special forms.
    ((list 'quote e) e)
    ((list 'cons x y)
     (cons (eval-expr x env) (eval-expr y env)))
    ((list 'car x)
     (car (eval-expr x env)))
    ((list 'cdr x)
     (cdr (eval-expr x env)))
    ((cons 'list xs) (eval-list xs env))
    ((cons 'tuple xs) (list_to_tuple (eval-list xs env)))
    ((cons 'binary bs) (eval-binary bs env))
    ;; Handle the Core closure special forms.
    ((cons 'lambda body)
     (eval-lambda body env))
    ((cons 'match-lambda cls)
     (eval-match-lambda cls env))
    ((cons 'let body)
     (eval-let body env))
    ((cons 'let-function body)
     (eval-let-function body env))
    ((cons 'letrec-function body)
     (eval-letrec-function body env))
    ;; Handle the Core control special forms.
    ((cons 'progn body) (eval-body body env))
    ((cons 'if body)
     (eval-if body env))
    ((cons 'case body)
     (eval-case body env))
    ((cons 'receive body)
     (eval-receive body env))
    ((cons 'catch body)
     (catch (eval-body body env)))
    ((cons 'try body)
     (eval-try body env))
    ((list* 'funcall f as)
     (erlang:apply (eval-expr f env) (eval-list as env)))
    ((cons 'call body)
     (eval-call body env))
    ;; General function calls.
    ((cons fun es) (when (is_atom fun))
     ;; Note that macros have already been expanded here.
     (let ((ar (length es)))        ;Arity
       (case (get_fbinding fun ar env)
         ((tuple 'yes m f) (erlang:apply m f (eval-list es env)))
         ((tuple 'yes f) (eval-apply f (eval-list es env) env))
         ('no (erlang:error (tuple 'unbound_func (tuple fun ar)))))))
    ((cons f es)
     (erlang:error (tuple 'bad_form 'application)))
    (e (if (is_atom e)
         (case (get_vbinding e env)
           ((tuple 'yes val) val)
           (no (erlang:error (tuple 'unbound_symb e))))
         e))))                ;Atoms evaluate to themselves

(defun eval-list (es env)
  (lists:map (lambda (e) (eval-expr e env)) es))

(defun eval-body (body env)
  (case body
    ((list e) (eval-expr e env))
    ((cons e es)
     (eval-expr e env) (eval-body es env))
    (() ())))

;; (eval-binary bitsegs env) -> binary.
;;   Construct a binary from bitsegs. This code is taken from eval_bits.erl.

(defun eval-binary (fs env)
  (let ((vsps (parse-bitsegs fs env)))
    (eval-bitsegs vsps env)))

(defrecord spec
  (type 'integer) (size 'default) (unit 'default)
  (sign 'default) (endian 'default))

(defun parse-bitsegs (fs env)
  ;;  (map (lambda (f) (parse-bitseg f env)) fs))
  (foldr (lambda (f vs) (parse-bitseg f vs env)) () fs))

;; Utility function to check if a value is a list of integers (string)
(defun is-integer-list
  ([(cons i is)] (when (is_integer i)) (is-integer-list is))
  ([()] 'true)
  ([_] 'false))

(defun parse-bitseg (f vsps env)
  ;; Test what structure the bitseg has.
  (cond ((is-integer-list f)        ;A string
         (let ((sp (parse-bitspecs () (make-spec) env)))
           (foldr (lambda (v vs) (cons (tuple v sp) vs)) vsps f)))
        ((?= (cons val specs) f)        ;A value and spec
         (let ((sp (parse-bitspecs specs (make-spec) env)))
           (if (is-integer-list val)
             (foldr (lambda (v vs) (cons (tuple v sp) vs)) vsps val)
             (cons (tuple val sp) vsps))))
        (else                ;A simple value
          (cons (tuple f (parse-bitspecs () (make-spec) env)) vsps))))

;; (defun parse-bitseg (f env)
;;   (case f
;;     ((cons pat specs) (tuple pat (parse-bitspecs specs (make-spec) env)))
;;     (pat (tuple pat (parse-bitspecs () (make-spec) env)))))

(defun eval-bitsegs (psps env)
  (foldl (lambda (psp acc)
           (let* (((tuple val spec) psp)
                  (bin (eval-bitseg val spec env)))
             (binary (acc bitstring) (bin bitstring))))
         #b() psps))

(defun eval-bitseg (val spec env)
  (let ((v (eval-expr val env)))
    (eval-exp-bitseg v spec)))

;; (parse-bitspecs specs spec env) -> (tuple type size unit sign end).

(defun parse-bitspecs (ss spec0 env)
  (let* ((spec1 (foldl (lambda (s spec) (parse-bitspec s spec env)) spec0 ss))
         ((match-spec type ty size sz unit un sign si endian en) spec1))
    ;; Adjust values depending on type and given value.
    (flet ((val-or-def (v def) (if (=:= v 'default) def v)))
      (case ty
        ('integer
         (tuple 'integer
                (val-or-def sz 8) (val-or-def un 1)
                (val-or-def si 'unsigned) (val-or-def en 'big)))
        ;; Ignore unused fields in utf types!
        ('utf8 (tuple 'utf8 'undefined 'undefined 'undefined 'undefined))
        ('utf16
         (tuple 'utf16 'undefined 'undefined 'undefined (val-or-def en 'big)))
        ('utf32
         (tuple 'utf32 'undefined 'undefined 'undefined (val-or-def en 'big)))
        ('float
         (tuple 'float
                (val-or-def sz 64) (val-or-def un 1)
                (val-or-def si 'unsigned) (val-or-def en 'big)))
        ('binary
         (tuple 'binary
                (val-or-def sz 'all) (val-or-def un 8)
                (val-or-def si 'unsigned) (val-or-def en 'big)))
        ('bitstring
         (tuple 'binary
                (val-or-def sz 'all) (val-or-def un 1)
                (val-or-def si 'unsigned) (val-or-def en 'big)))))))

(defun parse-bitspec (spec sp env)
  (case spec
    ;; Types.
    ('integer (set-spec-type sp 'integer))
    ('float (set-spec-type sp 'float))
    ('binary (set-spec-type sp 'binary))
    ('bytes (set-spec-type sp 'binary))
    ('bitstring (set-spec-type sp 'bitstring))
    ('bits (set-spec-type sp 'bitstring))
    ;; Unicode types.
    ('utf-8 (set-spec-type sp 'utf8))
    ('utf-16 (set-spec-type sp 'utf16))
    ('utf-32 (set-spec-type sp 'utf32))
    ;; Endianess.
    ('big-endian (set-spec-endian sp 'big))
    ('big (set-spec-endian sp 'big))
    ('little-endian (set-spec-endian sp 'little))
    ('little (set-spec-endian sp 'little))
    ('native-endian (set-spec-endian sp 'native))
    ('native (set-spec-endian sp 'native))
    ;; Sign.
    ('signed (set-spec-sign sp 'signed))
    ('unsigned (set-spec-sign sp 'unsigned))
    ;; Size
    ((list 'size n)
     (let ((size (eval-expr n env)))
       (set-spec-size sp size)))
    ((list 'unit n) (when (is_integer n) (> n 0))
     (set-spec-unit sp n))
    ;; Illegal spec.
    (_ (erlang:error (tuple 'illegal_bitspec spec)))))

;; (eval-exp-bitseg value type size unit sign endian) -> binary().

(defun eval-exp-bitseg (val spec)
  (case spec
    ;; Integer types.
    ((tuple 'integer sz un si en) (eval-int-bitseg val (* sz un) si en))
    ;; Unicode types, ignore unused specs.
    ((tuple 'utf8 _ _ _ _) (binary (val utf8)))
    ((tuple 'utf16 _ _ _ en) (eval-utf-16-bitseg val en))
    ((tuple 'utf32 _ _ _ en) (eval-utf-32-bitseg val en))
    ;; Float types.
    ((tuple 'float sz un _ en) (eval-float-bitseg val (* sz un) en))
    ;; Binary types.
    ((tuple 'binary 'all un _ _)
     (case (bit_size val)
       (size (when (=:= (rem size un) 0))
             (binary (val bitstring (size size))))
       (_ (erlang:error 'bad_arg))))
    ((tuple 'binary sz un _ _)
     (binary (val bitstring (size (* sz un)))))))

(defun eval-int-bitseg
  ([val sz 'signed 'big] (binary (val (size sz) signed big)))
  ([val sz 'unsigned 'big] (binary (val (size sz) unsigned big)))
  ([val sz 'signed 'little] (binary (val (size sz) signed little)))
  ([val sz 'unsigned 'little] (binary (val (size sz) unsigned little)))
  ([val sz 'signed 'native] (binary (val (size sz) signed native)))
  ([val sz 'unsigned 'native] (binary (val (size sz) unsigned native))))

(defun eval-utf-16-bitseg (val en)
  (case en
    ('big (binary (val utf16 big)))
    ('little (binary (val utf16 little)))
    ('native (binary (val utf16 native)))))

(defun eval-utf-32-bitseg (val en)
  (case en
    ('big (binary (val utf32 big)))
    ('little (binary (val utf32 little)))
    ('native (binary (val utf32 native)))))

(defun eval-float-bitseg (val sz en)
  (case en
    ('big (binary (val float (size sz) big)))
    ('little (binary (val float (size sz) little)))
    ('native (binary (val float (size sz) native)))))

;; (eval-lambda (lambda-body env)) -> val

(defun eval-lambda
  ([(cons args body) env]
   ;; This is a really ugly hack!
   (case (length args)
     (0 (lambda () (apply-lambda () body () env)))
     (1 (lambda (a) (apply-lambda args body (list a) env)))
     (2 (lambda (a b) (apply-lambda args body (list a b) env)))
     (3 (lambda (a b c) (apply-lambda args body (list a b c) env)))
     (4 (lambda (a b c d) (apply-lambda args body (list a b c d) env)))
     (5 (lambda (a b c d e) (apply-lambda args body (list a b c d e) env)))
     (6 (lambda (a b c d e f)
          (apply-lambda args body (list a b c d e f) env)))
     (7 (lambda (a b c d e f g)
          (apply-lambda args body (list a b c d e f g) env)))
     (8 (lambda (a b c d e f g h)
          (apply-lambda args body (list a b c d e f g h) env)))
     (9 (lambda (a b c d e f g h i)
          (apply-lambda args body (list a b c d e f g h i) env)))
     (10 (lambda (a b c d e f g h i j)
           (apply-lambda args body (list a b c d e f g h i j) env)))
     (11 (lambda (a b c d e f g h i j k)
           (apply-lambda args body (list a b c d e f g h i j k) env)))
     (12 (lambda (a b c d e f g h i j k l)
           (apply-lambda args body (list a b c d e f g h i j k l) env)))
     (13 (lambda (a b c d e f g h i j k l m)
           (apply-lambda args body (list a b c d e f g h i j k l m) env)))
     (14 (lambda (a b c d e f g h i j k l m n)
           (apply-lambda args body (list a b c d e f g h i j k l m n) env)))
     (15 (lambda (a b c d e f g h i j k l m n o)
           (apply-lambda args body (list a b c d e f g h i j k l m n o) env))))))

(defun apply-lambda (args body vals env)
  (fletrec ((bind-args
             ([(cons '_ as) (cons _ es) env]    ;Ignore don't care variables
              (bind-args as es env))
             ([(cons a as) (cons e es) env] (when (is_atom a))
              (bind-args as es (add_vbinding a e env)))
             ([() () env] env)))
    (eval-body body (bind-args args vals env))))

;; eval-match-lambda (MatchClauses Env) -> Value
;; Evaluate (match-lambda cls ...).

(defun eval-match-lambda (cls env)
  ;; This is a really ugly hack!
  (case (match-lambda-arity cls)
    (0 (lambda () (apply-match-clauses cls () env)))
    (1 (lambda (a) (apply-match-clauses cls (list a) env)))
    (2 (lambda (a b) (apply-match-clauses cls (list a b) env)))
    (3 (lambda (a b c) (apply-match-clauses cls (list a b c) env)))
    (4 (lambda (a b c d) (apply-match-clauses cls (list a b c d) env)))
    (5 (lambda (a b c d e) (apply-match-clauses cls (list a b c d e) env)))
    (6 (lambda (a b c d e f)
         (apply-match-clauses cls (list a b c d e f) env)))
    (7 (lambda (a b c d e f g)
         (apply-match-clauses cls (list a b c d e f g) env)))
    (8 (lambda (a b c d e f g h)
         (apply-match-clauses cls (list a b c d e f g h) env)))
    (9 (lambda (a b c d e f g h i)
         (apply-match-clauses cls (list a b c d e f g h i) env)))
    (10 (lambda (a b c d e f g h i j)
          (apply-match-clauses cls (list a b c d e f g h i j) env)))
    (11 (lambda (a b c d e f g h i j k)
          (apply-match-clauses cls (list a b c d e f g h i j k) env)))
    (12 (lambda (a b c d e f g h i j k l)
          (apply-match-clauses cls (list a b c d e f g h i j k l) env)))
    (13 (lambda (a b c d e f g h i j k l m)
          (apply-match-clauses cls (list a b c d e f g h i j k l m) env)))
    (14 (lambda (a b c d e f g h i j k l m n)
          (apply-match-clauses cls (list a b c d e f g h i j k l m n) env)))
    (15 (lambda (a b c d e f g h i j k l m n o)
          (apply-match-clauses cls (list a b c d e f g h i j k l m n o) env)))))

(defun match-lambda-arity (cls) (length (caar cls)))

(defun apply-match-clauses (cls as env)
  (case cls
    ((cons (cons pats body) cls)
     (if (== (length as) (length pats))
       ;; Sneaky! m-l args a list of patterns so wrap with list
       ;; and pass in as one pattern. Have already checked a
       ;; proper list.
       (case (match-when (cons 'list pats) as body env)
         ((tuple 'yes body1 vbs) (eval-body body1 (add_vbindings vbs env)))
         ('no (apply-match-clauses cls as env)))
       (erlang:error 'badarity)))
    (_ (erlang:error 'function_clause))))

;; (eval-let (PatBindings . Body) Env) -> Value.

(defun eval-let (body env0)
  (let* (((cons vbs b) body)        ;Must match this
         ;; Make sure we use the right environment.
         (env (foldl (match-lambda
                       ([(list pat e) env]
                        (let ((val (eval-expr e env0)))
                          (case (match pat val env0)
                            ((tuple 'yes bs) (add_vbindings bs env))
                            ('no (erlang:error (tuple 'badmatch val))))))
                       ([(list pat (= (cons 'when _) g) e) env]
                        (let ((val (eval-expr e env0)))
                          (case (match-when pat val (list g) env0)
                            ((tuple 'yes '() bs) (add_vbindings bs env))
                            ('no (erlang:error (tuple 'badmatch val))))))
                       ([_ _] (erlang:error (tuple 'bad_form 'let))))
                     env0 vbs)))
    (eval-body b env)))

;; (eval-let-function (FuncBindings . Body) Env) -> Value.

(defun eval-let-function (form env0)
  (flet ((add (f ar def lenv e)
              (add_fbinding f ar (tuple 'lexical_expr def lenv) e)))
    (let* (((cons fbs body) form)
           (env (foldl (match-lambda
                         ([(list v (= (list* 'lambda as _) f)) e]
                          (when (is_atom v))
                          (add v (length as) f env0 e))
                         ([(list v (= (list* 'match-lambda (cons pats _) _) f)) e]
                          (when (is_atom v))
                          (add v (length pats) f env0 e))
                         ([_ _] (erlang:error (tuple 'bad_form 'let-function))))
                       env0 fbs)))
      (eval-body body env))))

;; (eval-letrec-function (FuncBindings . Body) Env) -> Value.
;;  This is a tricky one. But we dynamically update the environment
;;  each time we are called.

(defun eval-letrec-function (form env0)
  (let* (((cons fbs0 body) form)
         (map-fun (match-lambda
                    ([(list v (= (list* 'lambda args _) f))]
                     (when (is_atom v))
                     (tuple v (length args) f))
                    ([(list v (= (list* 'match-lambda (cons pats _) _) f))]
                     (when (is_atom v))
                     (tuple v (length pats) f))
                    ([_] (erlang:error (tuple 'bad_form 'letrec-function)))))
         (fbs1 (lists:map map-fun fbs0))
         (env1 (make_letrec_env fbs1 env0)))
    (eval-body body env1)))

;; (make_letrec_env fbs env) -> env.
;;  Create local function bindings for a set of mutally recursive
;;  functions, for example from a module or a letrec-function. This is
;;  very similar to "Metacircular Semantics for Common Lisp Special
;;  Forms" by Henry Baker, except he uses macros whereas we directly
;;  fiddle with the environment and he keeps functions in a vector
;;  where we just push them into the environment. His version compiles
;;  much better (which we don't need) but is basically the same
;;  interpreted.

(defun make_letrec_env (fbs0 env)
  (let ((fbs (lists:map (lambda (fb)
                          (let (((tuple v ar body) fb))
                            (tuple v ar (tuple 'letrec body fbs0 env))))
                        fbs0)))
    (add_fbindings fbs env)))

;; (add_expr_func name arity def env) -> env.
;;  Add a function definition in the correct format to the
;;  environment.

(defun add_expr_func (name ar def env)
  (add_fbinding name ar (tuple 'lexical_expr def env) env))

;; (eval-apply function args env) -> value
;;  This is used to evaluate interpreted functions. Macros are
;;  expanded completely in the function definition before it is
;;  applied.

(defun eval-apply (f es env0)
  (case f
    ((tuple 'dynamic_expr func)
     (eval-apply-expr func es env0))
    ((tuple 'dynamic_expr func env)
     (eval-apply-expr func es env))
    ((tuple 'letrec body fbs env)
     ;; A function created by/for letrec-function.
     (let ((newenv (foldl (match-lambda
                            ([(tuple v ar lambda) e]
                             (add_fbinding v ar
                                           (tuple 'letrec lambda fbs env) e)))
                          env fbs)))
       (eval-apply-expr body es newenv)))))

;; (eval-apply-expr function args env) -> value
;;  Apply the function definition to the (evaluated) args in env.
;;  Macros are expanded first.

(defun eval-apply-expr (func es env)
  (case (lfe_macro:expand_expr_all func env)
    ((list* 'lambda args body) (apply-lambda args body es env))
    ((cons 'match-lambda cls) (apply-match-clauses cls es env))
    (fun (when (is_function fun)) (erlang:apply fun es))))

;; (eval-if body env) -> value

(defun eval-if (body env)
  (flet ((eval-if (test true false)
                  ;; Use explicit case to catch errors.
                  (case (eval-expr test env)
                    ('true (eval-expr true env))
                    ('false (eval-expr false env))
                    (_ (erlang:error 'if_clause)))))
    (case body
      ((list test true) (eval-if test true 'false))
      ((list test true false) (eval-if test true false)))))

;; (eval-case (expr . cls) env) -> value

(defun eval-case (body env)
  (eval-case-clauses (eval-expr (car body) env)
                     (cdr body) env))

(defun eval-case-clauses (v cls env)
  (case (match-clause v cls env)
    ((tuple 'yes b vbs)
     (eval-body b (add_vbindings vbs env)))
    ('no (erlang:error (tuple 'case_clause v)))))

(defun match-clause (v cls env)
  (case cls
    ((cons (cons pat body) cls)
     (case (match-when pat v body env)
       ((= (tuple 'yes body vbs) yes) yes)
       ('no (match-clause v cls env))))
    (() 'no)))

;; (eval-receive body env) -> value

(defun eval-receive (body env)
  (fletrec ((split-rec
             ([(list (list* 'after t b)) rcls]
              (tuple (reverse rcls) t b))
             ([(cons cl b) rcls]
              (split-rec b (cons cl rcls)))
             ([() rcls]            ;No timeout, return 'infinity
              (tuple (reverse rcls) 'infinity ()))))
    (let (((tuple cls te tb) (split-rec body [])))
      (case (eval-expr te env)
        ('infinity (receive-clauses cls env))
        (t (receive-clauses t tb cls env))))))

;; (receive-clauses Clauses Env) -> Value.
;;  Recurse down message queue. We are only called with timeout value
;;  of 'infinity'. Always pass over all messages in queue.

(defun receive-clauses (cls env)
  (fletrec ((rec-clauses
             (ms)
             (receive
               (msg (case (match-clause msg cls env)
                      ((tuple 'yes b vbs)
                       (merge-queue ms)
                       (eval-body b (add_vbindings vbs env)))
                      ('no (rec-clauses (cons msg ms))))))))
    (rec-clauses ())))

;; (receive-clauses Timeout TimeoutBody Clauses Env) -> Value.
;;  Recurse down message queue until timeout. We are never called with
;;  timeout value of 'infinity'. Always pass over all messages in
;;  queue.

(defun receive-clauses (t tb cls env)
  (fletrec ((rec-clauses
             (t ms)
             (receive
               (msg
                (case (match-clause msg cls env)
                  ((tuple 'yes b vbs)
                   (merge-queue ms)
                   (eval-body b (add_vbindings vbs env)))
                  ('no
                   (let (((tuple _ t1) (statistics 'runtime)))
                     (if (< t t1)
                       (rec-clauses 0 (cons msg ms))
                       (rec-clauses (- t t1) (cons msg ms)))))))
               (after t
                 (merge-queue ms)
                 (eval-body tb env)))))
    (statistics 'runtime)
    (rec-clauses t [])))

;; Merge the already received messages back into the process message
;; queue in the right order. Do this by first receiving the rest of
;; the messages in the queue then sending them all back to ourselves.

(defun merge-queue (ms)
  (fletrec ((recv-all (ms)        ;Receive all remaining messages
                      (receive
                        (msg (recv-all (cons msg ms)))
                        (after 0
                          (reverse ms))))
            (send-all (ms self)        ;Send them all back to ourselves
                      (case ms
                        ((cons m ms)
                         (! self m)
                         (send-all ms self))
                        (() 'ok))))
    (send-all (recv-all ms) (self))))

;; (eval-try body env) -> value
;;  Complicated by checking legal combinations of options.

(defun eval-try (body env)
  (case body
    ((list* e (cons 'case cls) catch)
     (eval-try-catch catch e (list cls) env))
    ((cons e catch)
     (eval-try-catch catch e () env))))

(defun eval-try-catch (body e case env)
  (case body
    ((list (cons 'catch cls))
     (eval-try e case (list cls) () env))
    ((list (cons 'catch cls) (cons 'after b))
     (eval-try e case (list cls) (list b) env))
    ((list (cons 'after b))
     (eval-try e case () (list b) env))))

(defun eval-try (e case catch after env)
  (try
      (eval-expr e env)
    (case
        (r (case case
             ((list cls) (eval-case-clauses r cls env))
             (() r))))
    (catch
      ;; Modern exception handling - stacktrace captured in pattern
      ((tuple class error stacktrace)
       (case catch
         ((list cls) (eval-catch-clauses (tuple class error stacktrace) cls env))
         (() (erlang:raise class error stacktrace)))))
    (after
        (case after
          ((list b) (eval-body b env))
          (() ())))))

(defun eval-catch-clauses
  ([v (cons (cons pat b) cls) env]
   (case (match-when pat v b env)
     ((tuple 'yes b vbs) (eval-body b (add_vbindings vbs env)))
     ('no (eval-catch-clauses v cls env))))
  ([(tuple class val stk) () _]
   (erlang:raise class val stk)))

(defun eval-call (b env)
  (case b
    ((list* m f as)
     (let ((m (eval-expr m env))
           (f (eval-expr f env))
           (as (eval-list as env)))
       (erlang:apply m f as)))))

;; (match-when pattern value body env) -> #('yes restbody bindings) | 'no.
;;  Try to match pattern and evaluate guard.

(defun match-when (pat val b0 env)
  (case (match pat val env)
    ((tuple 'yes vbs)
     (case b0
       ((cons (cons 'when g) b1)
        (if (eval-guard g (add_vbindings vbs env))
          (tuple 'yes b1 vbs)
          'no))
       (b1 (tuple 'yes b1 vbs))))
    ('no 'no)))

;; (eval-guard guardtests env) -> true | false.
;; Guards are fault safe, catch all errors in guards here and fail guard.

(defun eval-guard (gts env)
  (try
      (eval-gbody gts env)
    (case ('true 'true)
      (_ 'false))            ;Fail guard
    (catch
      ((tuple t v i) 'false))))        ;Fail guard

;; (eval-gbody body env) -> true | false.
;; A body is a sequence of tests which must all succeed.

(defun eval-gbody (es env)
  (lists:all (lambda (e) (eval-gexpr e env)) es))

;; (eval-gexpr sexpr environment) -> value.
;;  Evaluate a guard sexpr in the current environment.

(defun eval-gexpr (e env)
  (case e
    ;; Handle the Core data special forms.
    ((list 'quote e) e)
    ((list 'cons x y)
     (cons (eval-gexpr x env) (eval-gexpr y env)))
    ((list 'car x)
     (car (eval-gexpr x env)))
    ((list 'cdr x)
     (cdr (eval-gexpr x env)))
    ((cons 'list xs) (eval-glist xs env))
    ((cons 'tuple xs) (list_to_tuple (eval-glist xs env)))
    ((cons 'binary bs) (eval-gbinary bs env))
    ;; Handle the Core closure special forms.
    ;; Handle the Core control special forms.
    ((cons 'progn b) (eval-gbody b env))
    ((cons 'if b) (eval-gif b env))
    ((list* 'call 'erlang f as)
     (let ((f (eval-gexpr f env))
           (ar (length as)))
       (case (get_gbinding f ar env)
         ((tuple 'yes m f) (erlang:apply m f (eval-glist as env)))
         (_ (erlang:error (tuple 'unbound_func (tuple f (length as))))))))
    ((cons f as) (when (is_atom f))
     (let ((ar (length as)))
       (case (get_gbinding f ar env)
         ((tuple 'yes m f) (erlang:apply m f (eval-glist as env)))
         ('no (erlang:error (tuple 'unbound_func (tuple f ar)))))))
    ((cons f es)            ;Everything else not allowed
     (erlang:error 'illegal_guard))
    (e (if (is_atom e)
         (case (get_vbinding e env)
           ((tuple 'yes val) val)
           (no (erlang:error (tuple 'unbound_symb e))))
         e))))                ;Atoms evaluate to themselves

(defun eval-glist (es env)
  (lists:map (lambda (e) (eval-gexpr e env)) es))

;; (eval-gbinary bitsegs env) -> binary.
;;   Construct a binary from bitsegs. This code is taken from eval_bits.erl.

(defun eval-gbinary (fs env)
  (let ((vsps (parse-bitsegs fs env)))
    (eval-gbitsegs vsps env)))

(defun eval-gbitsegs (psps env)
  (foldl (lambda (psp acc)
           (let* (((tuple val spec) psp)
                  (bin (eval-gbitseg val spec env)))
             (binary (acc bitstring) (bin bitstring))))
         #b() psps))

(defun eval-gbitseg (val spec env)
  (let ((v (eval-gexpr val env)))
    (eval-exp-bitseg v spec)))

;; (eval-gif ifbody env) -> val

(defun eval-gif (body env)
  (flet ((eval-gif (test true false)
                   (if (eval-gexpr test env)
                     (eval-gexpr true env)
                     (eval-gexpr false env))))
    (case body
      ((list test true) (eval-gif test true 'false))
      ((list test true false) (eval-gif test true false)))))

;; (match pattern value env) -> (tuple 'yes bs) | 'no
;;  Try to match Pattern against Value within the current environment
;;  returning bindings. Bindings is an orddict.

(defun match (pat val env) (match pat val env ()))

(defun match
  ([(list 'quote p) val env bs]
   (if (=:= p val) (tuple 'yes bs) 'no))
  ([(cons 'tuple ps) val env bs]
   (if (is_tuple val)
     (match-list ps (tuple_to_list val) env bs)
     'no))
  ([(cons 'binary fs) val env bs]
   (if (is_bitstring val)
     (match-binary fs val env bs)
     'no))
  ([(list '= p1 p2) val env bs]        ;Aliases
   (case (match p1 val env bs)
     ((tuple 'yes bs) (match p2 val env bs))
     ('no 'no)))
  ([(list 'cons p ps) (cons v vs) env bs] ;Explicit cons constructor
   (case (match p v env bs)
     ((tuple 'yes bs) (match ps vs env bs))
     ('no 'no)))
  ([(cons 'list ps) val env bs]        ;Explicit list constructor
   (match-list ps val env bs))
  ;; Use old no contructor list forms.
  ([(cons p ps) (cons v vs) env bs]
   (case (match p v env bs)
     ((tuple 'yes bs) (match ps vs env bs))
     ('no 'no)))
  ;;  ([(cons _ _) _ _ _] 'no)        ;No constructor

  ([() () env bs] (tuple 'yes bs))
  ([symb val env bs] (when (is_atom symb))
   (match-symb symb val env bs))
  ([pat val env bs]
   (if (=:= pat val) (tuple 'yes bs) 'no)))

(defun match-list
  ([(cons p ps) (cons v vs) env bs]
   (case (match p v env bs)
     ((tuple 'yes bs) (match-list ps vs env bs))
     ('no 'no)))
  ([() () _ bs] (tuple 'yes bs))
  ([_ _ _ _] 'no))

(defun match-symb (symb val env bs)
  (if (== symb '_) (tuple 'yes bs)    ;Don't care variable
      ;; Check if symbol already bound.
      (case (find symb bs)
        ((tuple 'ok _) 'no)        ;Already bound, multiple variable
        ('error (tuple 'yes (store symb val bs))))))

;; (match-binary bitsegs binary env bindings) -> (tuple 'yes bindings) | 'no.
;;  Match Bitsegs against Binary. This code is taken from
;;  eval_bits.erl. All bitspec errors and bad matches result in an
;;  error, we use catch to trap it.

(defun match-binary (fs bin env bs)
  (let ((psps (parse-bitsegs fs env)))
    (case (catch (match-bitsegs psps bin env bs))
      ((tuple 'yes bs) (tuple 'yes bs))    ;Matched whole binary
      ((tuple 'EXIT _) 'no))))        ;Error is no match

(defun match-bitsegs
  ([(cons (tuple pat specs) psps) bin0 env bs0]
   (let (((tuple 'yes bin1 bs1) (match-bitseg pat specs bin0 env bs0)))
     (match-bitsegs psps bin1 env bs1)))
  ([() #b() _ bs] (tuple 'yes bs)))    ;Reached the end of both

(defun match-bitseg (pat spec bin0 env bs0)
  (let* (((tuple val bin1) (get-pat-bitseg bin0 spec))
         ((tuple 'yes bs1) (match pat val env bs0)))
    (tuple 'yes bin1 bs1)))

;; (get-pat-bitseg binary #(type size unit sign endian)) -> #(value restbinary)

(defun get-pat-bitseg (bin spec)
  (case spec
    ;; Integer types.
    ((tuple 'integer sz un si en) (get-int-bitseg bin (* sz un) si en))
    ;; Unicode types, ignore unused specs.
    ((tuple 'utf8 _ _ _ _) (get-utf-8-bitseg bin))
    ((tuple 'utf16 _ _ _ en) (get-utf-16-bitseg bin en))
    ((tuple 'utf32 _ _ _ en) (get-utf-32-bitseg bin en))
    ;; Float types.
    ((tuple 'float sz un _ en) (get-float-bitseg bin (* sz un) en))
    ;; Binary types.
    ((tuple 'binary 'all un _ _)
     (let ((0 (rem (bit_size bin) un)))
       (tuple bin #b())))
    ((tuple 'binary sz un _ _)
     (let* ((tot-size (* sz un))
            ((binary (val bitstring (size tot-size)) (rest bitstring)) bin))
       (tuple val rest)))))

(defun get-int-bitseg
  ([bin sz 'signed 'big]
   (let (((binary (val signed big (size sz))
                  (rest bitstring)) bin))
     (tuple val rest)))
  ([bin sz 'unsigned 'big]
   (let (((binary (val unsigned big (size sz))
                  (rest bitstring)) bin))
     (tuple val rest)))
  ([bin sz 'signed 'little]
   (let (((binary (val signed little (size sz))
                  (rest bitstring)) bin))
     (tuple val rest)))
  ([bin sz 'unsigned 'little]
   (let (((binary (val unsigned little (size sz))
                  (rest bitstring)) bin))
     (tuple val rest)))
  ([bin sz 'signed 'native]
   (let (((binary (val signed native (size sz))
                  (rest bitstring)) bin))
     (tuple val rest)))
  ([bin sz 'unsigned 'native]
   (let (((binary (val unsigned native (size sz))
                  (rest bitstring)) bin))
     (tuple val rest))))

(defun get-utf-8-bitseg (bin)
  (let (((binary (val utf8) (rest bitstring)) bin))
    (tuple val rest)))

(defun get-utf-16-bitseg (bin en)
  (case en
    ('big (let (((binary (val utf16 big) (rest bitstring)) bin))
            (tuple val rest)))
    ('little (let (((binary (val utf16 little) (rest bitstring)) bin))
               (tuple val rest)))
    ('native (let (((binary (val utf16 native) (rest bitstring)) bin))
               (tuple val rest)))))

(defun get-utf-32-bitseg (bin en)
  (case en
    ('big (let (((binary (val utf32 big) (rest bitstring)) bin))
            (tuple val rest)))
    ('little (let (((binary (val utf32 little) (rest bitstring)) bin))
               (tuple val rest)))
    ('native (let (((binary (val utf32 native) (rest bitstring)) bin))
               (tuple val rest)))))

(defun get-float-bitseg (bin sz en)
  (case en
    ('big
     (let (((binary (val float big (size sz)) (rest bitstring)) bin))
       (tuple val rest)))
    ('little
     (let (((binary (val float little (size sz)) (rest bitstring)) bin))
       (tuple val rest)))
    ('native
     (let (((binary (val float native (size sz)) (rest bitstring)) bin))
       (tuple val rest)))))
